{-# OPTIONS_GHC -XRecordWildCards -fglasgow-exts #-}
module WS.Runtime.Main (WsParams(..), wsProxy, runService, saveProxy) where 

import WS.Runtime.Xmlable (Xmlable (..))
import Text.XML.Light
import Data.Maybe
import Network.HTTP
import Data.Typeable
import Data.Time.LocalTime
import qualified Data.Map as Map
import Data.Traversable hiding (sequence)
import Data.Foldable (sequenceA_)
import Control.Concurrent.MVar
import Control.Monad
import Control.Arrow
import System.IO.UTF8 (readFile, writeFile)
import Prelude hiding (readFile, writeFile)

data WsParams = WsParams {
        wspServer :: String,
        wspProtocolStr :: String,
        wspAuthorization :: Maybe String,
        wspLog :: Maybe String,
        wspProxy :: Maybe String,
        wspLogMVar :: MVar (),
        wspProxyMVar :: MVar (Maybe (Map.Map String String))
    }

envURI :: String
envURI = "http://schemas.xmlsoap.org/soap/envelope/"
        
makeSoapEnvelope :: (Xmlable t) => [(String, String)] -> String -> t -> String
makeSoapEnvelope nss op x 
    | null elems = error "Empty content!"
    | otherwise = ppContent $
        Elem Element
            {
                elName 	  = QName {qName = "Envelope", qURI = Just envURI, qPrefix = Just "soapenv"},
                elAttribs = Attr {attrKey = QName {qName = "soapenv", qURI = Nothing, qPrefix = Just "xmlns"} , attrVal = envURI} :
                            [Attr {attrKey = QName {qName = pref, qURI = Nothing, qPrefix = Just "xmlns"} , attrVal = name} |
                                (pref, name) <- nss	
                            ],
                elContent = 
                    [
                        Elem Element
                            {
                                elName 	  = QName {qName = "Header", qURI = Just envURI, qPrefix = Just "soapenv"},
                                elAttribs = [],
                                elContent = [],
                                elLine = Nothing							
                            },
                        Elem Element
                            {
                                elName 	  = QName {qName = "Body", qURI = Just envURI, qPrefix = Just "soapenv"},
                                elAttribs = [],
                                elContent = let Elem e = head elems in
                                    [
                                        Elem Element
                                            {
                                                elContent = [Elem e],
                                                elName = QName {qName = op, qURI = qURI $ elName e, qPrefix = qPrefix $ elName e},
                                                elAttribs = [],
                                                elLine = Nothing
                                            }
                                    ],
                                elLine = Nothing							
                            }
                    ],
                elLine = Nothing
            } 
    where
        elems = concat $ toContent x
        
wsProxy :: Maybe FilePath -> IO (Maybe (Map.Map String String))
wsProxy Nothing = return Nothing
wsProxy (Just fp) = liftM (Just . (read :: String -> Map.Map String String))
        (catch (readFile fp) (return . show . const (Map.empty::(Map.Map String String))))

saveProxy :: WsParams -> IO ()
saveProxy wsp = takeMVar (wspProxyMVar wsp) >>= sequenceA_ . (>>= return . writeFile (fromJust $ wspProxy wsp) . show)

runService :: (Xmlable t1, Xmlable t2) => String -> [(String, String)] -> String -> WsParams -> t1 -> IO t2
runService service nss op (WsParams {wspProxy = _, ..}) x = 
        liftM (fromContent . (:[]) . map Elem . (>>=elChildren) . (>>=elChildren) . (>>=elChildren) . onlyElems . parseXML) proxy
    where
        soapEnv = makeSoapEnvelope nss op x
        runService' = do
            save_log $ \t -> "\nService " ++ service ++ " (op = " ++ op ++ ") was started at " ++ show t
            res <- simpleHTTP (postRequest $ "http://" ++ wspServer ++ "/" ++ service ++ "/" ++ wspProtocolStr) {
                    rqHeaders = [
                            Header HdrContentLength $ show $ length soapEnv,
                            Header HdrUserAgent "XI.Directory.WS",
                            Header HdrContentType "text/xml; charset=UTF-8"
                        ] ++ map (Header HdrAuthorization) (maybeToList wspAuthorization),
                    rqBody = soapEnv
                }
            save_log $ \t -> "Service " ++ service ++ " (op = " ++ op ++ ") was finished at " ++ show t ++ " "  ++ 
                    (("with error: " ++) . show ||| const "successfully") res
                    
            return $ case res of
                Left err -> error $ "service " ++ service ++ ": " ++ show err
                Right resp -> case cast $ rspBody resp :: Maybe String of
                    Nothing -> error $ "service " ++ service ++ " response body is not a string!"
                    Just s -> s

        save_log s = takeMVar wspLogMVar >> 
                sequenceA (wspLog >>= \fLog -> return $ getZonedTime >>= appendFile fLog . (++ "\n") . s) >> 
                putMVar wspLogMVar ()
                
        proxy = takeVar >>= (\mp -> 
                if isNothing mp 
                    then runS mp >>= uncurry put
                    else (\t -> if isNothing t 
                        then runS mp >>= \(mp',s) -> put (fmap (Map.insert soapEnv s) mp') s
                        else put mp $ fromJust t) (Map.lookup soapEnv $ fromJust mp))
            where
                put mp s = put0 mp >> return s
                takeVar = takeMVar wspProxyMVar
                put0 = putMVar wspProxyMVar
                runS mp = put0 mp >> runService' >>= (\s -> liftM (flip (,) s) takeVar)
